Najbardziej zaludnione hrabstwo znajdujące się w stanie Michigan w Stanach Zjednoczonych. Według danych z 2020r. znalazło się ono na 19. miejscu wśród najbardziej zaludnionych hrabstw w Stanach zjednoczonych. Jego obszar całkowity obejmuje powierzchnię 1 741 km². Siedziba hrabstwa znajduje się w Detroit. Detroit graniczy z kanadyjskim miastem Windsor.
Liczba ludności w hrabstwie Wayne:
1990: 2 111 687 2000: 2 061 162 2010: 1 820 574 2020: 1 793 561
Procentowy udział głównych grup rasowo-etnicznych 1990/2020:
Biała: 56.14/47.79 Afroamerykanie: 40.03/37.32 Latynosi: 2.39/6.56 Azjaci: 1.00/3.61 Rdzenni Amerykanie: 0.35/0.24 Inni : 0.08/4.48
W badanym okresie liczba ludności hrabstwa Wayne zmniejszyła się o ~15%. Zaobserwowano również zmiany w strukturze rasowo-etnicznej.
p1 <- ggplot(data = wayne_idx_1990) +
geom_sf(aes(fill = H)) +
scale_fill_gradient2(name = "Wskaźnik H", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "1990") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p2 <- ggplot(data = wayne_idx_2000) +
geom_sf(aes(fill = H)) +
scale_fill_gradient2(name = "Wskaźnik H", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "2000") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p3 <- ggplot(data = wayne_idx_2010) +
geom_sf(aes(fill = H)) +
scale_fill_gradient2(name = "Wskaźnik H", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "2010") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p4 <- ggplot(data = wayne_idx_2020) +
geom_sf(aes(fill = H)) +
scale_fill_gradient2(name = "Wskaźnik H", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) + # Consistent legend title
labs(title = "2020") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
print(p1)
print(p2)
print(p3)
print(p4)
cls_color <- c("L"= "#008000", "M"= "#FFFF00", "H"= "#FF0000")
colpal <- cls_color[names(cls_color)%in%unique(wayne_idx_1990$H_cls)]
wayne_idx_1990$H_cls <- factor(wayne_idx_1990$H_cls, levels = c("H", "M", "L"))
wayne_idx_2000$H_cls <- factor(wayne_idx_2000$H_cls, levels = c("H", "M", "L"))
wayne_idx_2010$H_cls <- factor(wayne_idx_2010$H_cls, levels = c("H", "M", "L"))
wayne_idx_2020$H_cls <- factor(wayne_idx_2020$H_cls, levels = c("H", "M", "L"))
p1 <- ggplot(data = wayne_idx_1990) +
geom_sf(aes(fill = H_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "1990", fill = "Wskaźnik H") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank())
p2 <- ggplot(data = wayne_idx_2000) +
geom_sf(aes(fill = H_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2000", fill = "Wskaźnik H") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
) +
guides(fill = 'none')
p3 <- ggplot(data = wayne_idx_2010) +
geom_sf(aes(fill = H_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2010", fill = "Wskaźnik H") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p4 <- ggplot(data = wayne_idx_2020) +
geom_sf(aes(fill = H_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2020", fill = "Wskaźnik H") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
) +
guides(fill = 'none')
combined2 <- p1 + p2 + p3 + p4 + plot_layout(guides = "collect") & theme(legend.position = "right")
combined2 = combined2 + plot_annotation("Klasyfikacja wkaźnika H na poziomie obszarow spisowych")
print(combined2)
Badając przestrzenny rozkład wartości wskaźnika H można zaobserwować różnice pomiędzy częściami Hrabstwa Wayne. W 2020 roku obszarem o największym poziomie segregacji rasowej były głównie obszary spisowe znajdujące się w centrum miasta, w szczególności te w północnej części. Porównując wizualizacje dla poszczególnych lat można również zaobserwować stopniowe zmiany na obszarze w skali czasowej gdzie wyróżnia się rzadziej zaludniona południowa część badanego obszaru. Widać tam spadek poziomu segregacji rasowej na przestrzeni okresu od 1990 do 2020. Pewną tendencją spadkową wykazało się również same centrum miasta gdzie w latach 1990 i 2010 występowały obszary o maksymalnej wartości wskaźnika teorii informacji H. Najmniejszą zmiennością wykazały się obszary położone na północ od centrum miasta gdzie poziom segregacji rasowej utrzymywał się na podobnym poziomie na przestrzeni badanego okresu. Ogólnie na podstawie map rozkładu wartości wskaźnika H można stwierdzieć, że poziom segregacji rasowej na terenie Hrabstwa Wayne w latach 1990-2020 stopniowo spadał.
p1 <- ggplot(data = wayne_idx_1990) +
geom_sf(aes(fill = Estd)) +
scale_fill_gradient2(name = "Entropia Zestandaryzowana", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "1990") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p2 <- ggplot(data = wayne_idx_2000) +
geom_sf(aes(fill = Estd)) +
scale_fill_gradient2(name = "Entropia Zestandaryzowana", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "2000") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p3 <- ggplot(data = wayne_idx_2010) +
geom_sf(aes(fill = Estd)) +
scale_fill_gradient2(name = "Entropia Zestandaryzowana", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "2010") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p4 <- ggplot(data = wayne_idx_2020) +
geom_sf(aes(fill = Estd)) +
scale_fill_gradient2(name = "Entropia Zestandaryzowana", low = "darkgreen",mid = "yellow", high = "red",midpoint = 0.5 ,limits = c(0, 1)) +
labs(title = "2020") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
print(p1)
print(p2)
print(p3)
print(p4)
cls_color <- c("L"= "#008000", "M"= "#FFFF00", "H"= "#FF0000")
colpal <- cls_color[names(cls_color)%in%unique(wayne_idx_1990$Estd_cls)]
wayne_idx_1990$Estd_cls <- factor(wayne_idx_1990$Estd_cls, levels = c("H", "M", "L"))
wayne_idx_2000$Estd_cls <- factor(wayne_idx_2000$Estd_cls, levels = c("H", "M", "L"))
wayne_idx_2010$Estd_cls <- factor(wayne_idx_2010$Estd_cls, levels = c("H", "M", "L"))
wayne_idx_2020$Estd_cls <- factor(wayne_idx_2020$Estd_cls, levels = c("H", "M", "L"))
p1 <- ggplot(data = wayne_idx_1990) +
geom_sf(aes(fill = Estd_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "1990", fill = "Entropia Zestandaryzowana") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank())
p2 <- ggplot(data = wayne_idx_2000) +
geom_sf(aes(fill = Estd_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2000", fill = "Entropia Zestandaryzowana") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
) +
guides(fill = 'none')
p3 <- ggplot(data = wayne_idx_2010) +
geom_sf(aes(fill = Estd_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2010", fill = "Entropia Zestandaryzowana") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p4 <- ggplot(data = wayne_idx_2020) +
geom_sf(aes(fill = Estd_cls)) +
scale_fill_manual(values = colpal) +
labs(title = "2020", fill = "Entropia Zestandaryzowana") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
) +
guides(fill = 'none')
combined2 <- p1 + p2 + p3 + p4 + plot_layout(guides = "collect") & theme(legend.position = "right")
combined2 = combined2 + plot_annotation("Klasyfikacja entropii zestandaryzowanej na poziomie obszarow spisowych")
print(combined2)
Na podstawie przestrzennej reprezentacji poziomu entropii zestandaryzowanej dla poszczególnych obszarów spisowych Hrabstwa Wayne można zauważyć drastyczne zmiany w poziomie zróżnicowania rasowego regionu. Podczas gdy w roku 1990 niemal jedynym obszarem o dużej różnorodności rasowej było centrum miasta, z każdą następną dekadą widać jak poziom zróżnicowania rasowego na obrzeżach miasta stopniowo rośnie. Podczas gdy w samym centrum różnorodniość etniczna również wzrosła, niezwykle gwałtowną tendencją wzrostową wykazały się rzadziej zaludnione południowe obszary spisowe Hrabstwa Wayne, gdzie w 1990 roku przeważały obszary o niskim poziomie zróżnicowania rasowego natomiast w roku 2020 dorównują one w swojej wieloetniczności poziomom obserwowanym w centrum. Najmniejszą zmiennością podobnie jak w przypadku wskaźnika H wykazały się tereny na północ od głównego skupiska miejskiego.
biv_colors = stevens.bluered()
names(biv_colors) = c("LL", "ML", "HL", "LM", "MM", "HM", "LH", "MH", "HH")
p1 <- ggplot(data = wayne_idx_1990) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
labs(title = "1990", fill = "Struktura rasowo-etniczna") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank())
p2 <- ggplot(data = wayne_idx_2000) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
labs(title = "2000", fill = "Struktura rasowo-etniczna") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p3 <- ggplot(data = wayne_idx_2010) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
labs(title = "2010", fill = "Struktura rasowo-etniczna") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
p4 <- ggplot(data = wayne_idx_2020) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
labs(title = "2020", fill = "Struktura rasowo-etniczna") +
theme_bw() + theme(
axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank()
)
print(p1)
print(p2)
print(p3)
print(p4)
Powyższy wykres przedstawia typy struktur rasowo etnicznych dla obszarów spisowych w Hrabstwie Wayne dla poszczególnych lat. Kategorie zostały stworzone poprzez kombinację klasyfikacji entropii zestandaryzowanej (pierwsza litera) i wzkaźnika H (druga litera): L - niski poziom, M - średni poziom, H - wysoki poziom. Na podstawie wizualizacji można zaobserwować, że podczas gdy w roku 1990 poza centrum miasta dominowały obszary o niskim zróżnicowaniu rasowym i niskiej segregacj (LL), w kolejnych latah coraz bardziej dominujące stały się obszary o średnim zróżnicowaniu i niskiej segregacj (ML). Zarówno w centrum jak i na obrzeżach miasta pojawiło się również znacznie więcej obszarów o wysokim zróżnicowaniu etnicznym i niskiej segregacji (HL). W żadnym z badanych lat nie wystąpiły natomiast obszary o wysokim poziomie segregacji i zróżnicowania rasowego. Zwłasza w pobliżu centrum pojawiło się dużo obszarów o średniej wartości obydwu wskaźników. Niezaskakująco, miejscem które wykazało się najmniejszą zmiennością w czasie są obszary znajdujące się na północny-zachód od śródmieścia.
table(wayne_idx_1990$biv_cls)
##
## HL LH LL LM ML MM
## 1 1 449 38 112 23
table(wayne_idx_2020$biv_cls)
##
## HL HM LL LM ML MM
## 40 1 225 14 305 14
3. Typ o dużym zróżnicowaniu - HD (żadna grupa nie
przekracza 50%)
knitr::include_graphics("result/raport/mapa_zmian.png")
Do zmian doszło praktycznie na większości obszarów
spisowych (część ludności białej bez zmian w południowej i północnej
części, podobnie wiele obszarów z ludnością czarną w mieście Detroit).
Na pierwszy rzut oka zauważamy spadek udziału ludności białej (z
dominacji >80% WL do dominacji 50%-80% WM). Za to ludność czarna na
przestrzeni lat zwiększa swój udział na przedmieściach Detroit (głównie
BM→BL). Również na przedmieściach pojawił się mniejszy i większy udział
Latynosów tym samym zmniejszając udział ludności białej i o dużym
zróżnicowaniu (HD→HM, WM→HM). Patrząc na zachód zauważamy zmniejszenie
udziału ludności białej na rzecz ludności o dużym zróżnicowaniu (WL→HD).
wayne_1990 = st_drop_geometry(wayne_1990)
wayne_1990 = select(wayne_1990, 1,'race_cls')
wayne_1990 = rename(wayne_1990, race_cls_1990 = race_cls)
wayne_2020 = st_drop_geometry(wayne_2020)
wayne_2020 = select(wayne_2020, 1,'race_cls')
wayne_2020 = rename(wayne_2020, race_cls_2020 = race_cls)
wayne_1990_2020 = merge(wayne_1990, wayne_2020, by = "GISJOIN")
# table(wayne_1990_2020$race_cls_1990)
# table(wayne_1990_2020$race_cls_2020)
trans_matrix = table(wayne_1990_2020$race_cls_1990, wayne_1990_2020$race_cls_2020)
# write.csv(trans_matrix, "dane\\transition_matrix.csv")
trans_matrix
##
## AM BL BM HD HL HM WL WM
## BL 0 153 20 1 0 0 0 0
## BM 1 28 15 10 0 0 0 4
## HD 0 2 1 3 1 2 0 2
## HM 0 0 0 0 1 0 0 0
## WL 1 7 16 48 0 0 124 139
## WM 0 11 9 8 3 8 1 6
Macierz ta przedstawia przejścia klas z 1990r. do 2020r. Wiersz
zawiera dane z 1990, zaś kolumny dla roku 2020. Przykładowo: wartość 20
(pierwszy wiersz, trzecia kolumna) oznacza, że 20 obszarów spisowych
sklasyfikowanych w roku 1990 jako BL już w roku 2020 zmieniło swój typ
na BM. Do największego przejścia doszło z WL do WM - 139 obszarów
spisowych.
Liczba obszarów spisowych według typów w 1990r.
rowSums(trans_matrix) # dla typów w 1990
## BL BM HD HM WL WM
## 174 58 11 1 335 46
Liczba obszarów spisowych według typów w 2020r.
colSums(trans_matrix) # dla typów w 2020
## AM BL BM HD HL HM WL WM
## 2 201 61 70 5 10 125 151
Po zsumowaniu wartości w wierszach i kolumnach widzimy, że największą dominację ma ludność biała oraz czarna. Sytuacja ta nie zmienia się w 2020, lecz udział WL spadł na rzecz WM, HD, BM.
## Wczytanie danych
wayne_aggr1990 = read.csv('dane\\wayne_aggr_1990.csv')
wayne_1990 = read.csv('dane\\wayne_1990.csv')
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
bnd_1990 <- st_read("dane\\wayne.gpkg", layer = "wayne_1990")
wayne_1990$tot = wayne_1990$whites + wayne_1990$blacks + wayne_1990$asians + wayne_1990$native_americans + wayne_1990$others + wayne_1990$latino
## Wczytanie funkcji
entropy = function(pi){
entropy = -sum(pi*log(pi), na.rm = TRUE)
return(entropy)}
bivcol = function(pal){
tit = substitute(pal)
pal = pal()
ncol = length(pal)
image(matrix(seq_along(pal), nrow = sqrt(ncol)),
axes = FALSE,
col = pal,
asp = 1)
mtext(tit)
}
#utworzenie ramki danych zawierajacej identyfikator obszaru spisowego (GISJOINT) oraz ogólną liczbę ludności dla każdego obszaru spisowego.
out_ct_1990 <- data.frame(GISJOIN_T = wayne_aggr1990$GISJOIN_T, pop = wayne_aggr1990$tot)
#obliczenie odsetka ras dla poszczegolnych obszarow spisowych (dane wejsciowe do obliczenia entropii)
perc_ct_1990 <- wayne_aggr1990[,list_race]/wayne_aggr1990$tot
#obliczenie entopii dla każdego obszaru spisowego oraz dodanie jej do obiektu out_ct
out_ct_1990$ent <- apply(perc_ct_1990, 1, entropy)
out_block_1990 <- data.frame(GISJOIN = wayne_1990$GISJOIN, GISJOIN_T = wayne_1990$GISJOIN_T, pop_i = wayne_1990$tot)
#obliczenie odsetka wg ras dla każdego bloku (dane wejsciowe do obliczenia entropii dla bloku)
perc_block_1990 <- wayne_1990[,list_race]/wayne_1990$tot
perc_block_1990[is.na(perc_block_1990)] <- 0
# obliczenie entropii dla każdego bloku
out_block_1990$ent_i <- apply(perc_block_1990, 1, entropy)
calc_df_1990 <- merge(out_ct_1990, out_block_1990, by="GISJOIN_T")
calc_df_1990 <- calc_df_1990[, c("GISJOIN_T", "GISJOIN", "pop", "pop_i", "ent", "ent_i")]
calc_df_1990$H <- calc_df_1990$pop_i*(calc_df_1990$ent-calc_df_1990$ent_i)/(calc_df_1990$ent*calc_df_1990$pop)
h_index_1990 <- aggregate(H~GISJOIN_T, calc_df_1990, sum)
out_ct_1990 <- merge(out_ct_1990, h_index_1990, by = "GISJOIN_T")
colnames(out_ct_1990) <- c("GISJOIN_T", "tot", "E", "H")
#obliczenie entropii standaryzowanej
out_ct_1990$Estd <- out_ct_1990$E/log(length(list_race))
out_1990 <- merge(wayne_aggr1990, out_ct_1990[,-2], by="GISJOIN_T")
biv_1990 <- expand.grid(ent = c("L", "M", "H"), h=c("L", "M", "H"))
biv_1990$biv_cls <- paste(biv_1990$ent,biv_1990$h, sep="")
out_1990$Estd_cls <- cut(out_1990$Estd, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_1990$H_cls <- cut(out_1990$H, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_1990$biv_cls <- paste(out_1990$Estd_cls, out_1990$H_cls, sep="")
## Zapisanie wyniku
#write.csv(out,"dane\\wayne_aggr_idx_1990.csv")
## Polaczenie wyliczonych danych z danymi przestrzennymi
bnd_attr_1990 <- merge(select(bnd_1990,-any_of(c(list_race,'tot'))), out_1990, by.x = "GISJOIN", by.y = "GISJOIN_T")
## Wizualizacja wkaznikow na mapach
#plot(bnd_attr_1990["H"])
#
#legenda
biv_colors = stevens.bluered()
names(biv_colors) = c("LL", "ML", "HL", "LM", "MM", "HM", "LH", "MH", "HH")
#
plot1 = ggplot(bnd_attr_1990) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
theme_bw() +
labs(title = "1990") +
theme(plot.title = element_text(size = 20, hjust = 0.5))
## Wczytanie danych
wayne_aggr2000 = read.csv('dane\\wayne_aggr_2000.csv')
wayne_2000 = read.csv('dane\\wayne_2000.csv')
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
bnd_2000 <- st_read("dane\\wayne.gpkg", layer = "wayne_2000")
wayne_2000$tot = wayne_2000$whites + wayne_2000$blacks + wayne_2000$asians + wayne_2000$native_americans + wayne_2000$others + wayne_2000$latino
## Wczytanie funkcji
entropy = function(pi){
entropy = -sum(pi*log(pi), na.rm = TRUE)
return(entropy)}
bivcol = function(pal){
tit = substitute(pal)
pal = pal()
ncol = length(pal)
image(matrix(seq_along(pal), nrow = sqrt(ncol)),
axes = FALSE,
col = pal,
asp = 1)
mtext(tit)
}
#utworzenie ramki danych zawierajacej identyfikator obszaru spisowego (GISJOINT) oraz ogólną liczbę ludności dla każdego obszaru spisowego.
out_ct_2000 <- data.frame(GISJOIN_T = wayne_aggr2000$GISJOIN_T, pop = wayne_aggr2000$tot)
#obliczenie odsetka ras dla poszczegolnych obszarow spisowych (dane wejsciowe do obliczenia entropii)
perc_ct_2000 <- wayne_aggr2000[,list_race]/wayne_aggr2000$tot
#obliczenie entopii dla każdego obszaru spisowego oraz dodanie jej do obiektu out_ct
out_ct_2000$ent <- apply(perc_ct_2000, 1, entropy)
out_block_2000 <- data.frame(GISJOIN = wayne_2000$GISJOIN, GISJOIN_T = wayne_2000$GISJOIN_T, pop_i = wayne_2000$tot)
#obliczenie odsetka wg ras dla każdego bloku (dane wejsciowe do obliczenia entropii dla bloku)
perc_block_2000 <- wayne_2000[,list_race]/wayne_2000$tot
perc_block_2000[is.na(perc_block_2000)] <- 0
# obliczenie entropii dla każdego bloku
out_block_2000$ent_i <- apply(perc_block_2000, 1, entropy)
calc_df_2000 <- merge(out_ct_2000, out_block_2000, by="GISJOIN_T")
calc_df_2000 <- calc_df_2000[, c("GISJOIN_T", "GISJOIN", "pop", "pop_i", "ent", "ent_i")]
calc_df_2000$H <- calc_df_2000$pop_i*(calc_df_2000$ent-calc_df_2000$ent_i)/(calc_df_2000$ent*calc_df_2000$pop)
h_index_2000 <- aggregate(H~GISJOIN_T, calc_df_2000, sum)
out_ct_2000 <- merge(out_ct_2000, h_index_2000, by = "GISJOIN_T")
colnames(out_ct_2000) <- c("GISJOIN_T", "tot", "E", "H")
#obliczenie entropii standaryzowanej
out_ct_2000$Estd <- out_ct_2000$E/log(length(list_race))
out_2000 <- merge(wayne_aggr2000, out_ct_2000[,-2], by="GISJOIN_T")
biv_2000 <- expand.grid(ent = c("L", "M", "H"), h=c("L", "M", "H"))
biv_2000$biv_cls <- paste(biv_2000$ent,biv_2000$h, sep="")
out_2000$Estd_cls <- cut(out_2000$Estd, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2000$H_cls <- cut(out_2000$H, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2000$biv_cls <- paste(out_2000$Estd_cls, out_2000$H_cls, sep="")
## Zapisanie wyniku
#write.csv(out,"dane\\wayne_aggr_idx_2000.csv")
## Polaczenie wyliczonych danych z danymi przestrzennymi
bnd_attr_2000 <- merge(select(bnd_2000,-any_of(c(list_race,'tot'))), out_2000, by.x = "GISJOIN", by.y = "GISJOIN_T")
## Wizualizacja wkaznikow na mapach
#plot(bnd_attr_2000["H"])
#
#legenda
biv_colors = stevens.bluered()
names(biv_colors) = c("LL", "ML", "HL", "LM", "MM", "HM", "LH", "MH", "HH")
#
plot2 = ggplot(bnd_attr_2000) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
theme_bw() +
labs(title = "2000") +
theme(plot.title = element_text(size = 20, hjust = 0.5))
## Wczytanie danych
wayne_aggr2010 = read.csv('dane\\wayne_aggr_2010.csv')
wayne_2010 = read.csv('dane\\wayne_2010.csv')
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
bnd_2010 <- st_read("dane\\wayne.gpkg", layer = "wayne_2010")
wayne_2010$tot = wayne_2010$whites + wayne_2010$blacks + wayne_2010$asians + wayne_2010$native_americans + wayne_2010$others + wayne_2010$latino
## Wczytanie funkcji
entropy = function(pi){
entropy = -sum(pi*log(pi), na.rm = TRUE)
return(entropy)}
bivcol = function(pal){
tit = substitute(pal)
pal = pal()
ncol = length(pal)
image(matrix(seq_along(pal), nrow = sqrt(ncol)),
axes = FALSE,
col = pal,
asp = 1)
mtext(tit)
}
#utworzenie ramki danych zawierajacej identyfikator obszaru spisowego (GISJOINT) oraz ogólną liczbę ludności dla każdego obszaru spisowego.
out_ct_2010 <- data.frame(GISJOIN_T = wayne_aggr2010$GISJOIN_T, pop = wayne_aggr2010$tot)
#obliczenie odsetka ras dla poszczegolnych obszarow spisowych (dane wejsciowe do obliczenia entropii)
perc_ct_2010 <- wayne_aggr2010[,list_race]/wayne_aggr2010$tot
#obliczenie entopii dla każdego obszaru spisowego oraz dodanie jej do obiektu out_ct
out_ct_2010$ent <- apply(perc_ct_2010, 1, entropy)
out_block_2010 <- data.frame(GISJOIN = wayne_2010$GISJOIN, GISJOIN_T = wayne_2010$GISJOIN_T, pop_i = wayne_2010$tot)
#obliczenie odsetka wg ras dla każdego bloku (dane wejsciowe do obliczenia entropii dla bloku)
perc_block_2010 <- wayne_2010[,list_race]/wayne_2010$tot
perc_block_2010[is.na(perc_block_2010)] <- 0
# obliczenie entropii dla każdego bloku
out_block_2010$ent_i <- apply(perc_block_2010, 1, entropy)
calc_df_2010 <- merge(out_ct_2010, out_block_2010, by="GISJOIN_T")
calc_df_2010 <- calc_df_2010[, c("GISJOIN_T", "GISJOIN", "pop", "pop_i", "ent", "ent_i")]
calc_df_2010$H <- calc_df_2010$pop_i*(calc_df_2010$ent-calc_df_2010$ent_i)/(calc_df_2010$ent*calc_df_2010$pop)
h_index_2010 <- aggregate(H~GISJOIN_T, calc_df_2010, sum)
out_ct_2010 <- merge(out_ct_2010, h_index_2010, by = "GISJOIN_T")
colnames(out_ct_2010) <- c("GISJOIN_T", "tot", "E", "H")
#obliczenie entropii standaryzowanej
out_ct_2010$Estd <- out_ct_2010$E/log(length(list_race))
out_2010 <- merge(wayne_aggr2010, out_ct_2010[,-2], by="GISJOIN_T")
biv_2010 <- expand.grid(ent = c("L", "M", "H"), h=c("L", "M", "H"))
biv_2010$biv_cls <- paste(biv_2010$ent,biv_2010$h, sep="")
out_2010$Estd_cls <- cut(out_2010$Estd, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2010$H_cls <- cut(out_2010$H, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2010$biv_cls <- paste(out_2010$Estd_cls, out_2010$H_cls, sep="")
## Zapisanie wyniku
#write.csv(out,"dane\\wayne_aggr_idx_2010.csv")
## Polaczenie wyliczonych danych z danymi przestrzennymi
bnd_attr_2010 <- merge(select(bnd_2010,-any_of(c(list_race,'tot'))), out_2010, by.x = "GISJOIN", by.y = "GISJOIN_T")
## Wizualizacja wkaznikow na mapach
#plot(bnd_attr_2010["H"])
#
#legenda
biv_colors = stevens.bluered()
names(biv_colors) = c("LL", "ML", "HL", "LM", "MM", "HM", "LH", "MH", "HH")
#
plot3 = ggplot(bnd_attr_2010) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
theme_bw() +
labs(title = "2010") +
theme(plot.title = element_text(size = 20, hjust = 0.5))
## Wczytanie danych
wayne_aggr2020 = read.csv('dane\\wayne_aggr_2020.csv')
wayne_2020 = read.csv('dane\\wayne_2020.csv')
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
bnd_2020 <- st_read("dane\\wayne.gpkg", layer = "wayne_2020")
wayne_2020$tot = wayne_2020$whites + wayne_2020$blacks + wayne_2020$asians + wayne_2020$native_americans + wayne_2020$others + wayne_2020$latino
## Wczytanie funkcji
entropy = function(pi){
entropy = -sum(pi*log(pi), na.rm = TRUE)
return(entropy)}
bivcol = function(pal){
tit = substitute(pal)
pal = pal()
ncol = length(pal)
image(matrix(seq_along(pal), nrow = sqrt(ncol)),
axes = FALSE,
col = pal,
asp = 1)
mtext(tit)
}
#utworzenie ramki danych zawierajacej identyfikator obszaru spisowego (GISJOINT) oraz ogólną liczbę ludności dla każdego obszaru spisowego.
out_ct_2020 <- data.frame(GISJOIN_T = wayne_aggr2020$GISJOIN_T, pop = wayne_aggr2020$tot)
#obliczenie odsetka ras dla poszczegolnych obszarow spisowych (dane wejsciowe do obliczenia entropii)
perc_ct_2020 <- wayne_aggr2020[,list_race]/wayne_aggr2020$tot
#obliczenie entopii dla każdego obszaru spisowego oraz dodanie jej do obiektu out_ct
out_ct_2020$ent <- apply(perc_ct_2020, 1, entropy)
out_block_2020 <- data.frame(GISJOIN = wayne_2020$GISJOIN, GISJOIN_T = wayne_2020$GISJOIN_T, pop_i = wayne_2020$tot)
#obliczenie odsetka wg ras dla każdego bloku (dane wejsciowe do obliczenia entropii dla bloku)
perc_block_2020 <- wayne_2020[,list_race]/wayne_2020$tot
perc_block_2020[is.na(perc_block_2020)] <- 0
# obliczenie entropii dla każdego bloku
out_block_2020$ent_i <- apply(perc_block_2020, 1, entropy)
calc_df_2020 <- merge(out_ct_2020, out_block_2020, by="GISJOIN_T")
calc_df_2020 <- calc_df_2020[, c("GISJOIN_T", "GISJOIN", "pop", "pop_i", "ent", "ent_i")]
calc_df_2020$H <- calc_df_2020$pop_i*(calc_df_2020$ent-calc_df_2020$ent_i)/(calc_df_2020$ent*calc_df_2020$pop)
h_index_2020 <- aggregate(H~GISJOIN_T, calc_df_2020, sum)
out_ct_2020 <- merge(out_ct_2020, h_index_2020, by = "GISJOIN_T")
colnames(out_ct_2020) <- c("GISJOIN_T", "tot", "E", "H")
#obliczenie entropii standaryzowanej
out_ct_2020$Estd <- out_ct_2020$E/log(length(list_race))
out_2020 <- merge(wayne_aggr2020, out_ct_2020[,-2], by="GISJOIN_T")
biv_2020 <- expand.grid(ent = c("L", "M", "H"), h=c("L", "M", "H"))
biv_2020$biv_cls <- paste(biv_2020$ent,biv_2020$h, sep="")
out_2020$Estd_cls <- cut(out_2020$Estd, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2020$H_cls <- cut(out_2020$H, breaks = c(0, 0.33, 0.66, 1), labels = c("L", "M", "H"), include.lowest = TRUE, right = TRUE)
out_2020$biv_cls <- paste(out_2020$Estd_cls, out_2020$H_cls, sep="")
## Zapisanie wyniku
#write.csv(out,"dane\\wayne_aggr_idx_2020.csv")
## Polaczenie wyliczonych danych z danymi przestrzennymi
bnd_attr_2020 <- merge(select(bnd_2020,-any_of(c(list_race,'tot'))), out_2020, by.x = "GISJOIN", by.y = "GISJOIN_T")
## Wizualizacja wkaznikow na mapach
#plot(bnd_attr_2020["H"])
#
#legenda
biv_colors = stevens.bluered()
names(biv_colors) = c("LL", "ML", "HL", "LM", "MM", "HM", "LH", "MH", "HH")
#
plot4 = ggplot(bnd_attr_2020) +
geom_sf(aes(fill = biv_cls)) +
scale_fill_manual(values = biv_colors) +
theme_bw() +
labs(title = "2020") +
theme(plot.title = element_text(size = 20, hjust = 0.5))
combined_plot1 <- plot1 + plot2 + plot3 + plot4 + plot_layout(ncol = 2)
combined_plot1
TUTAJ TEKST
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
wayne_stb_1990 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_1990')
wayne_stb_2000 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2000')
cls_df = data.frame(GISJOIN = wayne_stb_1990$GISJOIN,
cls1990 = wayne_stb_1990$race_cls,
cls2000 = wayne_stb_2000$race_cls)
st_geometry(cls_df)<-wayne_stb_2000$geom
#table(cls_df$cls1990)
#table(cls_df$cls2000)
tab1990 <- prop.table(table(cls_df$cls1990))*100
round(tab1990, 1)
tab2000 <- prop.table(table(cls_df$cls2000))*100
round(tab2000, 1)
tab <- table(cls_df$cls1990, cls_df$cls2000)
tab
rowSums(tab)
colSums(tab)
round(prop.table(table(cls_df$cls1990, cls_df$cls2000))*100, 1)
#plot(cls_df["cls1990"])
#plot(cls_df["cls2000"])
cls_color <- c("AL"= "#CD5555", "AM"= "#FF6A6A", "BL"= "#006400", "BM"= "#32CD32", "HD"= "#8F8F8F", "HL"= "#5D478B", "HM"= "#9370DB", "WL"= "#FF8C00", "WM"= "#FFD700")
col1990 <- cls_color[names(cls_color)%in%unique(cls_df$cls1990)]
col2000 <- cls_color[names(cls_color)%in%unique(cls_df$cls2000)]
p1 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls1990)) +
scale_fill_manual(values = col1990) +
labs(title = "Wayne, 1990") +
theme_bw() +
theme(legend.position="bottom")
p2 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2000)) +
scale_fill_manual(values = col2000) +
labs(title = "Wayne, 2000") +
theme_bw() +
theme(legend.position="bottom")
#wyswietlenie wykresow obok siebie
p1 + p2 + plot_annotation(title = "Zmiany między rokiem 1990-2000", theme = theme(plot.title = element_text(size = 20, hjust = 0.5)))
TUTAJ TEKST
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
wayne_stb_2000 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2000')
wayne_stb_2010 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2010')
cls_df = data.frame(GISJOIN = wayne_stb_2000$GISJOIN,
cls2000 = wayne_stb_2000$race_cls,
cls2010 = wayne_stb_2010$race_cls)
st_geometry(cls_df)<-wayne_stb_2010$geom
#table(cls_df$cls2000)
#table(cls_df$cls2010)
tab2000 <- prop.table(table(cls_df$cls2000))*100
round(tab2000, 1)
tab2010 <- prop.table(table(cls_df$cls2010))*100
round(tab2010, 1)
tab <- table(cls_df$cls2000, cls_df$cls2010)
tab
rowSums(tab)
colSums(tab)
round(prop.table(table(cls_df$cls2000, cls_df$cls2010))*100, 1)
#plot(cls_df["cls2000"])
#plot(cls_df["cls2010"])
cls_color <- c("AL"= "#CD5555", "AM"= "#FF6A6A", "BL"= "#006400", "BM"= "#32CD32", "HD"= "#8F8F8F", "HL"= "#5D478B", "HM"= "#9370DB", "WL"= "#FF8C00", "WM"= "#FFD700")
col2000 <- cls_color[names(cls_color)%in%unique(cls_df$cls2000)]
col2010 <- cls_color[names(cls_color)%in%unique(cls_df$cls2010)]
p1 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2000)) +
scale_fill_manual(values = col2000) +
labs(title = "Wayne, 2000") +
theme_bw() +
theme(legend.position="bottom")
p2 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2010)) +
scale_fill_manual(values = col2010) +
labs(title = "Wayne, 2010") +
theme_bw() +
theme(legend.position="bottom")
#wyswietlenie wykresow obok siebie
p1 + p2 + plot_annotation(title = "Zmiany między rokiem 2000-2010", theme = theme(plot.title = element_text(size = 20, hjust = 0.5)))
TUTAJ TEKST
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
wayne_stb_2010 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2010')
wayne_stb_2020 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2020')
cls_df = data.frame(GISJOIN = wayne_stb_2010$GISJOIN,
cls2010 = wayne_stb_2010$race_cls,
cls2020 = wayne_stb_2020$race_cls)
st_geometry(cls_df)<-wayne_stb_2020$geom
#table(cls_df$cls2010)
#table(cls_df$cls2020)
tab2010 <- prop.table(table(cls_df$cls2010))*100
round(tab2010, 1)
tab2020 <- prop.table(table(cls_df$cls2020))*100
round(tab2020, 1)
tab <- table(cls_df$cls2010, cls_df$cls2020)
tab
rowSums(tab)
colSums(tab)
round(prop.table(table(cls_df$cls2010, cls_df$cls2020))*100, 1)
#plot(cls_df["cls2010"])
#plot(cls_df["cls2020"])
cls_color <- c("AL"= "#CD5555", "AM"= "#FF6A6A", "BL"= "#006400", "BM"= "#32CD32", "HD"= "#8F8F8F", "HL"= "#5D478B", "HM"= "#9370DB", "WL"= "#FF8C00", "WM"= "#FFD700")
col2010 <- cls_color[names(cls_color)%in%unique(cls_df$cls2010)]
col2020 <- cls_color[names(cls_color)%in%unique(cls_df$cls2020)]
p1 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2010)) +
scale_fill_manual(values = col2010) +
labs(title = "Wayne, 2010") +
theme_bw() +
theme(legend.position="bottom")
p2 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2020)) +
scale_fill_manual(values = col2020) +
labs(title = "Wayne, 2020") +
theme_bw() +
theme(legend.position="bottom")
#wyswietlenie wykresow obok siebie
p1 + p2 + plot_annotation(title = "Zmiany między rokiem 2010-2020", theme = theme(plot.title = element_text(size = 20, hjust = 0.5)))
TUTAJ TEKST
list_race <- c("whites", "blacks", "asians", "native_americans", "others", "latino")
wayne_stb_1990 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_1990')
wayne_stb_2020 = st_read("dane//wayne.gpkg", layer = 'wayne_stb_2020')
cls_df = data.frame(GISJOIN = wayne_stb_1990$GISJOIN,
cls1990 = wayne_stb_1990$race_cls,
cls2020 = wayne_stb_2020$race_cls)
st_geometry(cls_df)<-wayne_stb_2020$geom
#table(cls_df$cls1990)
#table(cls_df$cls2020)
tab1990 <- prop.table(table(cls_df$cls1990))*100
round(tab1990, 1)
tab2020 <- prop.table(table(cls_df$cls2020))*100
round(tab2020, 1)
tab <- table(cls_df$cls1990, cls_df$cls2020)
tab
rowSums(tab)
colSums(tab)
round(prop.table(table(cls_df$cls1990, cls_df$cls2020))*100, 1)
#plot(cls_df["cls1990"])
#plot(cls_df["cls2020"])
cls_color <- c("AL"= "#CD5555", "AM"= "#FF6A6A", "BL"= "#006400", "BM"= "#32CD32", "HD"= "#8F8F8F", "HL"= "#5D478B", "HM"= "#9370DB", "WL"= "#FF8C00", "WM"= "#FFD700")
col1990 <- cls_color[names(cls_color)%in%unique(cls_df$cls1990)]
col2020 <- cls_color[names(cls_color)%in%unique(cls_df$cls2020)]
p1 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls1990)) +
scale_fill_manual(values = col1990) +
labs(title = "Wayne, 1990") +
theme_bw() +
theme(legend.position="bottom")
p2 <- ggplot(data = cls_df) +
geom_sf(aes(fill = cls2020)) +
scale_fill_manual(values = col2020) +
labs(title = "Wayne, 2020") +
theme_bw() +
theme(legend.position="bottom")
#wyswietlenie wykresow obok siebie
p1 + p2 + plot_annotation(title = "Zmiany między rokiem 1990-2020", theme = theme(plot.title = element_text(size = 20, hjust = 0.5)))
TUTAJ TEKST
library(kableExtra)
cls_color <- c("#FF8C00", "#FFD700", "#006400", "#32CD32", "#CD5555", "#FF6A6A", "#5D478B", "#9370DB", "#8F8F8F")
data_p <- data.frame(
race_str = c("WL", "WM", "BL", "BM", "AL", "AM", "HL", "HM", "HD"),
r_1990 = c(335, 46, 174, 58, 0, 0, 0, 1, 11),
r_2000 = c(261, 75, 208, 48, 0, 0, 0, 11, 22),
r_2010 = c(210, 107, 222, 43, 0, 0, 0, 18, 25),
r_2020 = c(125, 151, 201, 61, 0, 2, 5, 10, 70)
)
data_p %>%
kbl() %>%
kable_classic_2(full_width = F) %>%
column_spec(1, background = cls_color)
| race_str | r_1990 | r_2000 | r_2010 | r_2020 |
|---|---|---|---|---|
| WL | 335 | 261 | 210 | 125 |
| WM | 46 | 75 | 107 | 151 |
| BL | 174 | 208 | 222 | 201 |
| BM | 58 | 48 | 43 | 61 |
| AL | 0 | 0 | 0 | 0 |
| AM | 0 | 0 | 0 | 2 |
| HL | 0 | 0 | 0 | 5 |
| HM | 1 | 11 | 18 | 10 |
| HD | 11 | 22 | 25 | 70 |
TUTAJ TEKST
# Wczytanie danych dla roku 1990 i 2000
wayne_1990 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_1990")
wayne_2000 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2000")
wayne_1990 = st_drop_geometry(wayne_1990)
wayne_1990 = select(wayne_1990, 1,'race_cls')
wayne_1990 = rename(wayne_1990, race_cls_1990 = race_cls)
wayne_2000 = st_drop_geometry(wayne_2000)
wayne_2000 = select(wayne_2000, 1,'race_cls')
wayne_2000 = rename(wayne_2000, race_cls_2000 = race_cls)
wayne_1990_2000 = merge(wayne_1990, wayne_2000, by = "GISJOIN")
table(wayne_1990_2000$race_cls_1990)
table(wayne_1990_2000$race_cls_2000)
trans_matrix1 = table(wayne_1990_2000$race_cls_1990, wayne_1990_2000$race_cls_2000)
trans_matrix1
t1 = trans_matrix1 %>%
kbl(caption = "<span style='font-size:20px'>Macierz przejść między rokiem 1990-2000</span>") %>%
kable_classic_2(full_width = F) %>%
kable_styling(bootstrap_options = "striped", latex_options = "scale_down") %>%
column_spec(1, bold = TRUE, color = "white", background = "#333") %>%
row_spec(0, bold = TRUE, color = "white", background = "#333") %>%
column_spec(2:7, bold = TRUE, color = "white", background = "gray")
# Wczytanie danych dla roku 2000 i 2010
wayne_2000 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2000")
wayne_2010 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2010")
wayne_2000 = st_drop_geometry(wayne_2000)
wayne_2000 = select(wayne_2000, 1,'race_cls')
wayne_2000 = rename(wayne_2000, race_cls_2000 = race_cls)
wayne_2010 = st_drop_geometry(wayne_2010)
wayne_2010 = select(wayne_2010, 1,'race_cls')
wayne_2010 = rename(wayne_2010, race_cls_2010 = race_cls)
wayne_2000_2010 = merge(wayne_2000, wayne_2010, by = "GISJOIN")
table(wayne_2000_2010$race_cls_2000)
table(wayne_2000_2010$race_cls_2010)
trans_matrix2 = table(wayne_2000_2010$race_cls_2000, wayne_2000_2010$race_cls_2010)
t2 = trans_matrix2 %>%
kbl(caption = "<span style='font-size:20px'>Macierz przejść między rokiem 2000-2010</span>") %>%
kable_classic_2(full_width = F) %>%
kable_styling(bootstrap_options = "striped", latex_options = "scale_down") %>%
column_spec(1, bold = TRUE, color = "white", background = "#333") %>%
row_spec(0, bold = TRUE, color = "white", background = "#333") %>%
column_spec(2:7, bold = TRUE, color = "white", background = "gray")
# Wczytanie danych dla roku 2010 i 2020
wayne_2010 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2010")
wayne_2020 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2020")
wayne_2010 = st_drop_geometry(wayne_2010)
wayne_2010 = select(wayne_2010, 1,'race_cls')
wayne_2010 = rename(wayne_2010, race_cls_2010 = race_cls)
wayne_2020 = st_drop_geometry(wayne_2020)
wayne_2020 = select(wayne_2020, 1,'race_cls')
wayne_2020 = rename(wayne_2020, race_cls_2020 = race_cls)
wayne_2010_2020 = merge(wayne_2010, wayne_2020, by = "GISJOIN")
table(wayne_2010_2020$race_cls_2010)
table(wayne_2010_2020$race_cls_2020)
trans_matrix3 = table(wayne_2010_2020$race_cls_2010, wayne_2010_2020$race_cls_2020)
t3 = trans_matrix3 %>%
kbl(caption = "<span style='font-size:20px'>Macierz przejść między rokiem 2010-2020</span>") %>%
kable_classic_2(full_width = F) %>%
kable_styling(bootstrap_options = "striped", latex_options = "scale_down") %>%
column_spec(1, bold = TRUE, color = "white", background = "#333") %>%
row_spec(0, bold = TRUE, color = "white", background = "#333") %>%
column_spec(2:9, bold = TRUE, color = "white", background = "gray")
# Wczytanie danych dla roku 1990 i 2020
wayne_1990 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_1990")
wayne_2020 <- st_read("dane//wayne.gpkg", layer = "wayne_stb_2020")
wayne_1990 = st_drop_geometry(wayne_1990)
wayne_1990 = select(wayne_1990, 1,'race_cls')
wayne_1990 = rename(wayne_1990, race_cls_1990 = race_cls)
wayne_2020 = st_drop_geometry(wayne_2020)
wayne_2020 = select(wayne_2020, 1,'race_cls')
wayne_2020 = rename(wayne_2020, race_cls_2020 = race_cls)
wayne_1990_2020 = merge(wayne_1990, wayne_2020, by = "GISJOIN")
table(wayne_1990_2020$race_cls_1990)
table(wayne_1990_2020$race_cls_2020)
trans_matrix4 = table(wayne_1990_2020$race_cls_1990, wayne_1990_2020$race_cls_2020)
t4 = trans_matrix4 %>%
kbl(caption = "<span style='font-size:20px'>Macierz przejść między rokiem 1990-2020</span>") %>%
kable_classic_2(full_width = F) %>%
kable_styling(bootstrap_options = "striped", latex_options = "scale_down") %>%
column_spec(1, bold = TRUE, color = "white", background = "#333") %>%
row_spec(0, bold = TRUE, color = "white", background = "#333") %>%
column_spec(2:9, bold = TRUE, color = "white", background = "gray")
# Łączenie tabel
library(htmltools)
combined_tables <- HTML(paste(
'<div style="display: grid; grid-template-columns: 1fr 1fr; gap: 1px; row-gap: 20px; column-gap: 1px">',
'<div>', t1, '</div>',
'<div>', t2, '</div>',
'<div>', t3, '</div>',
'<div>', t4, '</div>',
'</div>'
))
# Wyświetlanie
browsable(tagList(combined_tables))
| BL | BM | HD | HM | WL | WM | |
|---|---|---|---|---|---|---|
| BL | 173 | 1 | 0 | 0 | 0 | 0 |
| BM | 30 | 26 | 1 | 0 | 1 | 0 |
| HD | 2 | 2 | 4 | 3 | 0 | 0 |
| HM | 0 | 0 | 0 | 1 | 0 | 0 |
| WL | 0 | 7 | 3 | 0 | 259 | 66 |
| WM | 3 | 12 | 14 | 7 | 1 | 9 |
| BL | BM | HD | HM | WL | WM | |
|---|---|---|---|---|---|---|
| BL | 204 | 3 | 1 | 0 | 0 | 0 |
| BM | 17 | 26 | 3 | 0 | 0 | 2 |
| HD | 1 | 5 | 8 | 7 | 0 | 1 |
| HM | 0 | 0 | 0 | 11 | 0 | 0 |
| WL | 0 | 1 | 2 | 0 | 199 | 59 |
| WM | 0 | 8 | 11 | 0 | 11 | 45 |
| AM | BL | BM | HD | HL | HM | WL | WM | |
|---|---|---|---|---|---|---|---|---|
| BL | 0 | 197 | 24 | 1 | 0 | 0 | 0 | 0 |
| BM | 0 | 4 | 24 | 12 | 0 | 0 | 0 | 3 |
| HD | 1 | 0 | 7 | 12 | 0 | 1 | 0 | 4 |
| HM | 0 | 0 | 0 | 3 | 5 | 9 | 0 | 1 |
| WL | 0 | 0 | 1 | 13 | 0 | 0 | 123 | 73 |
| WM | 1 | 0 | 5 | 29 | 0 | 0 | 2 | 70 |
| AM | BL | BM | HD | HL | HM | WL | WM | |
|---|---|---|---|---|---|---|---|---|
| BL | 0 | 153 | 20 | 1 | 0 | 0 | 0 | 0 |
| BM | 1 | 28 | 15 | 10 | 0 | 0 | 0 | 4 |
| HD | 0 | 2 | 1 | 3 | 1 | 2 | 0 | 2 |
| HM | 0 | 0 | 0 | 0 | 1 | 0 | 0 | 0 |
| WL | 1 | 7 | 16 | 48 | 0 | 0 | 124 | 139 |
| WM | 0 | 11 | 9 | 8 | 3 | 8 | 1 | 6 |
TUTAJ TEKST
wayne_stb_1990$cls90 = recode(wayne_stb_1990$race_cls, "WL"= 1, "WM" = 2, "BL" = 3, "BM" = 4, "AL" = 5, "AM" = 6, "HL" = 7, "HM" = 8, "HD" = 9)
rast90 <- raster(wayne_stb_1990, res = 100)
# rast90
cls90 = fasterize(wayne_stb_1990, rast90, field = "cls90", fun="sum")
cls_color <- c("#FF8C00", "#FFD700", "#006400", "#32CD32", "#CD5555", "#FF6A6A", "#5D478B", "#9370DB", "#8F8F8F")
# plot(cls90, col = cls_color)
class_metr = list_lsm(level = "class")
lm90 = calculate_lsm(cls90, level = ("class"), what = c("lsm_c_np", "lsm_c_lpi", "lsm_c_pland", "lsm_c_ai"))
lm_df90 = pivot_wider(lm90[, c("class", "metric", "value")], names_from = metric, values_from = value)
# lm_df90
cls_code90 = data.frame(cls90 = c("WL", "WM", "BL", "BM", "AL", "AM", "HL", "HM", "HD"), class = 1:9)
results90 = merge(cls_code90, lm_df90, by = "class", all.x = TRUE)
# write.csv(results00, "dane/landscape_metrics_2000.csv", row.names = FALSE)
np90 = lsm_l_np(cls90)
# np90
lpi90 = lsm_l_lpi(cls90)
# lpi90
plot(cls90, col = cls_color, main = "1990")
results90 %>%
kbl() %>%
kable_classic_2(full_width = F) %>%
column_spec(1, background = cls_color)
| class | cls90 | ai | lpi | np | pland |
|---|---|---|---|---|---|
| 1 | WL | 99.30027 | 66.1031995 | 24 | 70.3879671 |
| 2 | WM | 96.35258 | 2.9613283 | 21 | 9.1252923 |
| 3 | BL | 98.29305 | 12.4091972 | 5 | 13.8270339 |
| 4 | BM | 93.55324 | 1.9960991 | 14 | 5.6694715 |
| 5 | AL | NA | NA | NA | NA |
| 6 | AM | NA | NA | NA | NA |
| 7 | HL | NA | NA | NA | NA |
| 8 | HM | 93.38843 | 0.0431352 | 1 | 0.0431352 |
| 9 | HD | 93.29268 | 0.2969455 | 8 | 0.9470999 |
W 1990r. dominuje przeważająco ludność biała, zajmując
łącznie 79,5% obszaru oraz mając najwięcej płatów, zaraz za nią plasuje
się ludność czarna zajmując ok. 19,5%. Najmniej ma kolejno ludność o
dużym zróżnicowaniu oraz Latynosi. Brak danych dla ludności azjatyckiej
(lub brak takiej ludności). Agregacja jest bardzo wysoka - płaty mają
znikome rozproszenie.
wayne_stb_2000$cls00 = recode(wayne_stb_2000$race_cls, "WL"= 1, "WM" = 2, "BL" = 3, "BM" = 4, "AL" = 5, "AM" = 6, "HL" = 7, "HM" = 8, "HD" = 9)
rast00 <- raster(wayne_stb_2000, res = 100)
# rast00
cls00 = fasterize(wayne_stb_2000, rast00, field = "cls00", fun="sum")
# plot(cls00, col = cls_color)
lm00 = calculate_lsm(cls00, level = ("class"), what = c("lsm_c_np", "lsm_c_lpi", "lsm_c_pland", "lsm_c_ai"))
lm_df00 = pivot_wider(lm00[, c("class", "metric", "value")], names_from = metric, values_from = value)
# lm_df00
cls_code00 = data.frame(cls00 = c("WL", "WM", "BL", "BM", "AL", "AM", "HL", "HM", "HD"), class = 1:9)
results00 = merge(cls_code00, lm_df00, by = "class", all.x = TRUE)
# write.csv(results00, "dane/landscape_metrics_2000.csv", row.names = FALSE)
np00 = lsm_l_np(cls00)
# np00
lpi00 = lsm_l_lpi(cls00)
# lpi00
plot(cls00, col = cls_color, main = "2000")
results00 %>%
kbl() %>%
kable_classic_2(full_width = F) %>%
column_spec(1, background = cls_color)
| class | cls00 | ai | lpi | np | pland |
|---|---|---|---|---|---|
| 1 | WL | 98.96183 | 56.2333554 | 22 | 59.6566685 |
| 2 | WM | 96.96735 | 7.3461197 | 18 | 16.2726147 |
| 3 | BL | 98.32376 | 9.4272390 | 6 | 16.5301759 |
| 4 | BM | 92.87581 | 0.7939386 | 16 | 4.5992173 |
| 5 | AL | NA | NA | NA | NA |
| 6 | AM | NA | NA | NA | NA |
| 7 | HL | NA | NA | NA | NA |
| 8 | HM | 96.58839 | 0.7270477 | 1 | 0.7270477 |
| 9 | HD | 93.56692 | 0.7826859 | 10 | 2.2142759 |
W 2000r. zauważamy względem 1990r. spadek zajętego
obszaru WL o 10,7 p.p.. oraz wzrost zajętego obszaru WM o 7,1 p.p.
Również niewielkie zmiany dla ludności czarnej oraz ludności o dużym
zróżnicowaniu. Nadal brak danych dla Azjatów. Zaś agregacja nadal na
wysokim poziomie.
wayne_stb_2010$cls10 = recode(wayne_stb_2010$race_cls, "WL"= 1, "WM" = 2, "BL" = 3, "BM" = 4, "AL" = 5, "AM" = 6, "HL" = 7, "HM" = 8, "HD" = 9)
rast10 <- raster(wayne_stb_2010, res = 100)
# rast10
cls10 = fasterize(wayne_stb_2010, rast10, field = "cls10", fun="sum")
# plot(cls10, col = cls_color)
lm10 = calculate_lsm(cls10, level = ("class"), what = c("lsm_c_np", "lsm_c_lpi", "lsm_c_pland", "lsm_c_ai"))
lm_df10 = pivot_wider(lm10[, c("class", "metric", "value")], names_from = metric, values_from = value)
# lm_df10
cls_code10 = data.frame(cls10 = c("WL", "WM", "BL", "BM", "AL", "AM", "HL", "HM", "HD"), class = 1:9)
results10 = merge(cls_code10, lm_df10, by = "class", all.x = TRUE)
# write.csv(results10, "dane/landscape_metrics_2010.csv", row.names = FALSE)
np10 = lsm_l_np(cls10)
# np10
lpi10 = lsm_l_lpi(cls10)
# lpi10
plot(cls10, col = cls_color, main = "2010")
results10 %>%
kbl() %>%
kable_classic_2(full_width = F) %>%
column_spec(1, background = cls_color)
| class | cls10 | ai | lpi | np | pland |
|---|---|---|---|---|---|
| 1 | WL | 98.53427 | 41.9562146 | 27 | 48.198947 |
| 2 | WM | 97.43675 | 13.1024868 | 20 | 23.559345 |
| 3 | BL | 98.69360 | 16.6620822 | 6 | 17.499156 |
| 4 | BM | 93.94016 | 0.9833585 | 17 | 5.008064 |
| 5 | AL | NA | NA | NA | NA |
| 6 | AM | NA | NA | NA | NA |
| 7 | HL | NA | NA | NA | NA |
| 8 | HM | 96.92421 | 1.2990585 | 1 | 1.299058 |
| 9 | HD | 94.11597 | 1.1665271 | 16 | 4.435428 |
W 2010r. względem 1990r. zauważamy jeszcze większe
zmiany w obszarze zajętym przez ludność. WL traci łącznie 22,2 p.p., WM
zyskuje 14,4 p.p. Ludność czarna zyskuje 3 p.p. Zwiększyła się liczba
płatów, która wpłynęła na stosunek powierzchni największego płata do
powierzchni obszaru. W tym przypadku wartości zmieniają się bardzo dla
WL oraz WM, w mniejszym stopniu dla BL. Jednak nie ma to wpływu na
poziom agregacji, który nadal jest bardzo wysoki.
wayne_stb_2020$cls20 = recode(wayne_stb_2020$race_cls, "WL"= 1, "WM" = 2, "BL" = 3, "BM" = 4, "AL" = 5, "AM" = 6, "HL" = 7, "HM" = 8, "HD" = 9)
rast20 <- raster(wayne_stb_2020, res = 100)
# rast20
cls20 = fasterize(wayne_stb_2020, rast20, field = "cls20", fun="sum")
# plot(cls20, col = cls_color)
lm20 = calculate_lsm(cls20, level = ("class"), what = c("lsm_c_np", "lsm_c_lpi", "lsm_c_pland", "lsm_c_ai"))
lm_df20 = pivot_wider(lm20[, c("class", "metric", "value")], names_from = metric, values_from = value)
# lm_df20
cls_code20 = data.frame(cls20 = c("WL", "WM", "BL", "BM", "AL", "AM", "HL", "HM", "HD"), class = 1:9)
results20 = merge(cls_code20, lm_df20, by = "class", all.x = TRUE)
# write.csv(results20, "dane/landscape_metrics_2020.csv", row.names = FALSE)
np20 = lsm_l_np(cls20)
# np20
lpi20 = lsm_l_lpi(cls20)
# lpi20
plot(cls20, col = cls_color, main = "2020")
results20 %>%
kbl() %>%
kable_classic_2(full_width = F) %>%
column_spec(1, background = cls_color)
| class | cls20 | ai | lpi | np | pland |
|---|---|---|---|---|---|
| 1 | WL | 97.59520 | 14.2365062 | 29 | 30.4103475 |
| 2 | WM | 97.40495 | 19.1720534 | 19 | 32.9303210 |
| 3 | BL | 98.14948 | 14.9679299 | 5 | 15.7743714 |
| 4 | BM | 94.13289 | 1.7072805 | 22 | 7.1848314 |
| 5 | AL | NA | NA | NA | NA |
| 6 | AM | 97.01727 | 0.2106750 | 1 | 0.2106750 |
| 7 | HL | 91.57895 | 0.0962729 | 4 | 0.2806917 |
| 8 | HM | 94.97189 | 0.9802328 | 2 | 1.0264938 |
| 9 | HD | 94.61415 | 3.7533914 | 30 | 12.1822683 |
W 2020r. porównując do 1990r. dochodzi do największych
zmian w udziale zajętego obszaru. WL traci aż 40 p.p., WM zyskuje 23,8
p.p., ludność czarna zyskuje 3,45 p.p. (1,8 p.p. względem 2000 roku oraz
0,45 p.p. względem 2010 roku). Liczba płatów zmnieniła się na korzyść
ludości o dużym zróżnicowaniu HD - 30 względem 8 z 1990r. Wartości lpi
jeszcze bardziej się zmniejszyły względem 2010r. choć niewiele wzrosło w
przypadku HD oraz WM. Na dodatek pojawili się Azjaci o średnim
zróżnicowaniu. Najmniejsza agregacja występuje u Latynosów o niskim
zróżnicowaniu - świadczy to o tym, że część komórek tej klasy nie
graniczy ze sobą.